home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zunk1.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  21.5 KB  |  511 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (let ((zeror 0.0) (zeroi 0.0) (coner 1.0) (pi_ 3.141592653589793))
  12.   (declare (type double-float pi_ coner zeroi zeror))
  13.   (defun zunk1 (zr zi fnu kode mr n yr yi nz tol elim alim)
  14.     (declare (type (simple-array double-float (*)) yr yi)
  15.              (type f2cl-lib:integer4 kode mr n nz)
  16.              (type double-float zr zi fnu tol elim alim))
  17.     (prog ((bry (make-array 3 :element-type 'double-float))
  18.            (init (make-array 2 :element-type 'f2cl-lib:integer4))
  19.            (sumr (make-array 2 :element-type 'double-float))
  20.            (sumi (make-array 2 :element-type 'double-float))
  21.            (zeta1r (make-array 2 :element-type 'double-float))
  22.            (zeta1i (make-array 2 :element-type 'double-float))
  23.            (zeta2r (make-array 2 :element-type 'double-float))
  24.            (zeta2i (make-array 2 :element-type 'double-float))
  25.            (cyr (make-array 2 :element-type 'double-float))
  26.            (cyi (make-array 2 :element-type 'double-float))
  27.            (cwrkr (make-array 48 :element-type 'double-float))
  28.            (cwrki (make-array 48 :element-type 'double-float))
  29.            (cssr (make-array 3 :element-type 'double-float))
  30.            (csrr (make-array 3 :element-type 'double-float))
  31.            (phir (make-array 2 :element-type 'double-float))
  32.            (phii (make-array 2 :element-type 'double-float)) (i 0) (ib 0)
  33.            (iflag 0) (ifn 0) (il 0) (inu 0) (iuf 0) (k 0) (kdflg 0) (kflag 0)
  34.            (kk 0) (nw 0) (initd 0) (ic 0) (ipard 0) (j 0) (m 0) (ang 0.0)
  35.            (aphi 0.0) (asc 0.0) (ascle 0.0) (cki 0.0) (ckr 0.0) (crsc 0.0)
  36.            (cscl 0.0) (csgni 0.0) (cspni 0.0) (cspnr 0.0) (csr 0.0) (c1i 0.0)
  37.            (c1r 0.0) (c2i 0.0) (c2m 0.0) (c2r 0.0) (fmr 0.0) (fn 0.0) (fnf 0.0)
  38.            (phidi 0.0) (phidr 0.0) (rast 0.0) (razr 0.0) (rs1 0.0) (rzi 0.0)
  39.            (rzr 0.0) (sgn 0.0) (sti 0.0) (str 0.0) (sumdi 0.0) (sumdr 0.0)
  40.            (s1i 0.0) (s1r 0.0) (s2i 0.0) (s2r 0.0) (zet1di 0.0) (zet1dr 0.0)
  41.            (zet2di 0.0) (zet2dr 0.0) (zri 0.0) (zrr 0.0))
  42.       (declare
  43.        (type (simple-array double-float (2)) zeta2r zeta2i zeta1r zeta1i sumr
  44.         sumi phir phii cyr cyi)
  45.        (type (simple-array double-float (48)) cwrkr cwrki)
  46.        (type (simple-array double-float (3)) cssr csrr bry)
  47.        (type double-float zrr zri zet2dr zet2di zet1dr zet1di s2r s2i s1r s1i
  48.         sumdr sumdi str sti sgn rzr rzi rs1 razr rast phidr phidi fnf fn fmr
  49.         c2r c2m c2i c1r c1i csr cspnr cspni csgni cscl crsc ckr cki ascle asc
  50.         aphi ang)
  51.        (type (simple-array f2cl-lib:integer4 (2)) init)
  52.        (type f2cl-lib:integer4 m j ipard ic initd nw kk kflag kdflg k iuf inu
  53.         il ifn iflag ib i))
  54.       (setf kdflg 1)
  55.       (setf nz 0)
  56.       (setf cscl (/ 1.0 tol))
  57.       (setf crsc tol)
  58.       (f2cl-lib:fset (f2cl-lib:fref cssr (1) ((1 3))) cscl)
  59.       (f2cl-lib:fset (f2cl-lib:fref cssr (2) ((1 3))) coner)
  60.       (f2cl-lib:fset (f2cl-lib:fref cssr (3) ((1 3))) crsc)
  61.       (f2cl-lib:fset (f2cl-lib:fref csrr (1) ((1 3))) crsc)
  62.       (f2cl-lib:fset (f2cl-lib:fref csrr (2) ((1 3))) coner)
  63.       (f2cl-lib:fset (f2cl-lib:fref csrr (3) ((1 3))) cscl)
  64.       (f2cl-lib:fset (f2cl-lib:fref bry (1) ((1 3)))
  65.                      (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  66.       (f2cl-lib:fset (f2cl-lib:fref bry (2) ((1 3)))
  67.                      (/ 1.0 (f2cl-lib:fref bry (1) ((1 3)))))
  68.       (f2cl-lib:fset (f2cl-lib:fref bry (3) ((1 3))) (f2cl-lib:d1mach 2))
  69.       (setf zrr zr)
  70.       (setf zri zi)
  71.       (if (>= zr 0.0) (go label10))
  72.       (setf zrr (- zr))
  73.       (setf zri (- zi))
  74.      label10
  75.       (setf j 2)
  76.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  77.                     ((> i n) nil)
  78.         (tagbody
  79.           (setf j (f2cl-lib:int-sub 3 j))
  80.           (setf fn (+ fnu (f2cl-lib:int-sub i 1)))
  81.           (f2cl-lib:fset (f2cl-lib:fref init (j) ((1 2))) 0)
  82.           (multiple-value-bind
  83.               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  84.                var-10 var-11 var-12 var-13 var-14 var-15 var-16)
  85.               (zunik zrr zri fn 2 0 tol (f2cl-lib:fref init (j) ((1 2)))
  86.                (f2cl-lib:fref phir (j) ((1 2)))
  87.                (f2cl-lib:fref phii (j) ((1 2)))
  88.                (f2cl-lib:fref zeta1r (j) ((1 2)))
  89.                (f2cl-lib:fref zeta1i (j) ((1 2)))
  90.                (f2cl-lib:fref zeta2r (j) ((1 2)))
  91.                (f2cl-lib:fref zeta2i (j) ((1 2)))
  92.                (f2cl-lib:fref sumr (j) ((1 2)))
  93.                (f2cl-lib:fref sumi (j) ((1 2)))
  94.                (f2cl-lib:fref cwrkr (1 j) ((1 16) (1 3)))
  95.                (f2cl-lib:fref cwrki (1 j) ((1 16) (1 3))))
  96.             (declare
  97.              (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
  98.             (f2cl-lib:fset (f2cl-lib:fref init (j) ((1 2))) var-6)
  99.             (f2cl-lib:fset (f2cl-lib:fref phir (j) ((1 2))) var-7)
  100.             (f2cl-lib:fset (f2cl-lib:fref phii (j) ((1 2))) var-8)
  101.             (f2cl-lib:fset (f2cl-lib:fref zeta1r (j) ((1 2))) var-9)
  102.             (f2cl-lib:fset (f2cl-lib:fref zeta1i (j) ((1 2))) var-10)
  103.             (f2cl-lib:fset (f2cl-lib:fref zeta2r (j) ((1 2))) var-11)
  104.             (f2cl-lib:fset (f2cl-lib:fref zeta2i (j) ((1 2))) var-12)
  105.             (f2cl-lib:fset (f2cl-lib:fref sumr (j) ((1 2))) var-13)
  106.             (f2cl-lib:fset (f2cl-lib:fref sumi (j) ((1 2))) var-14))
  107.           (if (= kode 1) (go label20))
  108.           (setf str (+ zrr (f2cl-lib:fref zeta2r (j) ((1 2)))))
  109.           (setf sti (+ zri (f2cl-lib:fref zeta2i (j) ((1 2)))))
  110.           (setf rast (/ fn (zabs str sti)))
  111.           (setf str (* str rast rast))
  112.           (setf sti (* (- sti) rast rast))
  113.           (setf s1r (- (f2cl-lib:fref zeta1r (j) ((1 2))) str))
  114.           (setf s1i (- (f2cl-lib:fref zeta1i (j) ((1 2))) sti))
  115.           (go label30)
  116.          label20
  117.           (setf s1r
  118.                   (- (f2cl-lib:fref zeta1r (j) ((1 2)))
  119.                      (f2cl-lib:fref zeta2r (j) ((1 2)))))
  120.           (setf s1i
  121.                   (- (f2cl-lib:fref zeta1i (j) ((1 2)))
  122.                      (f2cl-lib:fref zeta2i (j) ((1 2)))))
  123.          label30
  124.           (setf rs1 s1r)
  125.           (if (> (abs rs1) elim) (go label60))
  126.           (if (= kdflg 1) (setf kflag 2))
  127.           (if (< (abs rs1) alim) (go label40))
  128.           (setf aphi
  129.                   (zabs (f2cl-lib:fref phir (j) ((1 2)))
  130.                    (f2cl-lib:fref phii (j) ((1 2)))))
  131.           (setf rs1 (+ rs1 (f2cl-lib:flog aphi)))
  132.           (if (> (abs rs1) elim) (go label60))
  133.           (if (= kdflg 1) (setf kflag 1))
  134.           (if (< rs1 0.0) (go label40))
  135.           (if (= kdflg 1) (setf kflag 3))
  136.          label40
  137.           (setf s2r
  138.                   (-
  139.                    (* (f2cl-lib:fref phir (j) ((1 2)))
  140.                       (f2cl-lib:fref sumr (j) ((1 2))))
  141.                    (* (f2cl-lib:fref phii (j) ((1 2)))
  142.                       (f2cl-lib:fref sumi (j) ((1 2))))))
  143.           (setf s2i
  144.                   (+
  145.                    (* (f2cl-lib:fref phir (j) ((1 2)))
  146.                       (f2cl-lib:fref sumi (j) ((1 2))))
  147.                    (* (f2cl-lib:fref phii (j) ((1 2)))
  148.                       (f2cl-lib:fref sumr (j) ((1 2))))))
  149.           (setf str (* (exp s1r) (f2cl-lib:fref cssr (kflag) ((1 3)))))
  150.           (setf s1r (* str (cos s1i)))
  151.           (setf s1i (* str (sin s1i)))
  152.           (setf str (- (* s2r s1r) (* s2i s1i)))
  153.           (setf s2i (+ (* s1r s2i) (* s2r s1i)))
  154.           (setf s2r str)
  155.           (if (/= kflag 1) (go label50))
  156.           (multiple-value-bind
  157.               (var-0 var-1 var-2 var-3 var-4)
  158.               (zuchk s2r s2i nw (f2cl-lib:fref bry (1) ((1 3))) tol)
  159.             (declare (ignore var-0 var-1 var-3 var-4))
  160.             (setf nw var-2))
  161.           (if (/= nw 0) (go label60))
  162.          label50
  163.           (f2cl-lib:fset (f2cl-lib:fref cyr (kdflg) ((1 2))) s2r)
  164.           (f2cl-lib:fset (f2cl-lib:fref cyi (kdflg) ((1 2))) s2i)
  165.           (f2cl-lib:fset (f2cl-lib:fref yr (i) ((1 n)))
  166.                          (* s2r (f2cl-lib:fref csrr (kflag) ((1 3)))))
  167.           (f2cl-lib:fset (f2cl-lib:fref yi (i) ((1 n)))
  168.                          (* s2i (f2cl-lib:fref csrr (kflag) ((1 3)))))
  169.           (if (= kdflg 2) (go label75))
  170.           (setf kdflg 2)
  171.           (go label70)
  172.          label60
  173.           (if (> rs1 0.0) (go label300))
  174.           (if (< zr 0.0) (go label300))
  175.           (setf kdflg 1)
  176.           (f2cl-lib:fset (f2cl-lib:fref yr (i) ((1 n))) zeror)
  177.           (f2cl-lib:fset (f2cl-lib:fref yi (i) ((1 n))) zeroi)
  178.           (setf nz (f2cl-lib:int-add nz 1))
  179.           (if (= i 1) (go label70))
  180.           (if
  181.            (and (= (f2cl-lib:fref yr ((f2cl-lib:int-sub i 1)) ((1 n))) zeror)
  182.                 (= (f2cl-lib:fref yi ((f2cl-lib:int-sub i 1)) ((1 n))) zeroi))
  183.            (go label70))
  184.           (f2cl-lib:fset (f2cl-lib:fref yr ((f2cl-lib:int-sub i 1)) ((1 n)))
  185.                          zeror)
  186.           (f2cl-lib:fset (f2cl-lib:fref yi ((f2cl-lib:int-sub i 1)) ((1 n)))
  187.                          zeroi)
  188.           (setf nz (f2cl-lib:int-add nz 1))
  189.          label70))
  190.       (setf i n)
  191.      label75
  192.       (setf razr (/ 1.0 (zabs zrr zri)))
  193.       (setf str (* zrr razr))
  194.       (setf sti (* (- zri) razr))
  195.       (setf rzr (* (+ str str) razr))
  196.       (setf rzi (* (+ sti sti) razr))
  197.       (setf ckr (* fn rzr))
  198.       (setf cki (* fn rzi))
  199.       (setf ib (f2cl-lib:int-add i 1))
  200.       (if (< n ib) (go label160))
  201.       (setf fn (+ fnu (f2cl-lib:int-sub n 1)))
  202.       (setf ipard 1)
  203.       (if (/= mr 0) (setf ipard 0))
  204.       (setf initd 0)
  205.       (multiple-value-bind
  206.           (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10
  207.            var-11 var-12 var-13 var-14 var-15 var-16)
  208.           (zunik zrr zri fn 2 ipard tol initd phidr phidi zet1dr zet1di zet2dr
  209.            zet2di sumdr sumdi (f2cl-lib:fref cwrkr (1 3) ((1 16) (1 3)))
  210.            (f2cl-lib:fref cwrki (1 3) ((1 16) (1 3))))
  211.         (declare (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
  212.         (setf initd var-6)
  213.         (setf phidr var-7)
  214.         (setf phidi var-8)
  215.         (setf zet1dr var-9)
  216.         (setf zet1di var-10)
  217.         (setf zet2dr var-11)
  218.         (setf zet2di var-12)
  219.         (setf sumdr var-13)
  220.         (setf sumdi var-14))
  221.       (if (= kode 1) (go label80))
  222.       (setf str (+ zrr zet2dr))
  223.       (setf sti (+ zri zet2di))
  224.       (setf rast (/ fn (zabs str sti)))
  225.       (setf str (* str rast rast))
  226.       (setf sti (* (- sti) rast rast))
  227.       (setf s1r (- zet1dr str))
  228.       (setf s1i (- zet1di sti))
  229.       (go label90)
  230.      label80
  231.       (setf s1r (- zet1dr zet2dr))
  232.       (setf s1i (- zet1di zet2di))
  233.      label90
  234.       (setf rs1 s1r)
  235.       (if (> (abs rs1) elim) (go label95))
  236.       (if (< (abs rs1) alim) (go label100))
  237.       (setf aphi (zabs phidr phidi))
  238.       (setf rs1 (+ rs1 (f2cl-lib:flog aphi)))
  239.       (if (< (abs rs1) elim) (go label100))
  240.      label95
  241.       (if (> (abs rs1) 0.0) (go label300))
  242.       (if (< zr 0.0) (go label300))
  243.       (setf nz n)
  244.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  245.                     ((> i n) nil)
  246.         (tagbody
  247.           (f2cl-lib:fset (f2cl-lib:fref yr (i) ((1 n))) zeror)
  248.           (f2cl-lib:fset (f2cl-lib:fref yi (i) ((1 n))) zeroi)
  249.          label96))
  250.       (go end_label)
  251.      label100
  252.       (setf s1r (f2cl-lib:fref cyr (1) ((1 2))))
  253.       (setf s1i (f2cl-lib:fref cyi (1) ((1 2))))
  254.       (setf s2r (f2cl-lib:fref cyr (2) ((1 2))))
  255.       (setf s2i (f2cl-lib:fref cyi (2) ((1 2))))
  256.       (setf c1r (f2cl-lib:fref csrr (kflag) ((1 3))))
  257.       (setf ascle (f2cl-lib:fref bry (kflag) ((1 3))))
  258.       (f2cl-lib:fdo (i ib (f2cl-lib:int-add i 1))
  259.                     ((> i n) nil)
  260.         (tagbody
  261.           (setf c2r s2r)
  262.           (setf c2i s2i)
  263.           (setf s2r (+ (- (* ckr c2r) (* cki c2i)) s1r))
  264.           (setf s2i (+ (* ckr c2i) (* cki c2r) s1i))
  265.           (setf s1r c2r)
  266.           (setf s1i c2i)
  267.           (setf ckr (+ ckr rzr))
  268.           (setf cki (+ cki rzi))
  269.           (setf c2r (* s2r c1r))
  270.           (setf c2i (* s2i c1r))
  271.           (f2cl-lib:fset (f2cl-lib:fref yr (i) ((1 n))) c2r)
  272.           (f2cl-lib:fset (f2cl-lib:fref yi (i) ((1 n))) c2i)
  273.           (if (>= kflag 3) (go label120))
  274.           (setf str (coerce (abs c2r) 'double-float))
  275.           (setf sti (coerce (abs c2i) 'double-float))
  276.           (setf c2m (max str sti))
  277.           (if (<= c2m ascle) (go label120))
  278.           (setf kflag (f2cl-lib:int-add kflag 1))
  279.           (setf ascle (f2cl-lib:fref bry (kflag) ((1 3))))
  280.           (setf s1r (* s1r c1r))
  281.           (setf s1i (* s1i c1r))
  282.           (setf s2r c2r)
  283.           (setf s2i c2i)
  284.           (setf s1r (* s1r (f2cl-lib:fref cssr (kflag) ((1 3)))))
  285.           (setf s1i (* s1i (f2cl-lib:fref cssr (kflag) ((1 3)))))
  286.           (setf s2r (* s2r (f2cl-lib:fref cssr (kflag) ((1 3)))))
  287.           (setf s2i (* s2i (f2cl-lib:fref cssr (kflag) ((1 3)))))
  288.           (setf c1r (f2cl-lib:fref csrr (kflag) ((1 3))))
  289.          label120))
  290.      label160
  291.       (if (= mr 0) (go end_label))
  292.       (setf nz 0)
  293.       (setf fmr (coerce (the f2cl-lib:integer4 mr) 'double-float))
  294.       (setf sgn (coerce (- (f2cl-lib:dsign pi_ fmr)) 'double-float))
  295.       (setf csgni sgn)
  296.       (setf inu (f2cl-lib:int fnu))
  297.       (setf fnf (- fnu inu))
  298.       (setf ifn (f2cl-lib:int-sub (f2cl-lib:int-add inu n) 1))
  299.       (setf ang (* fnf sgn))
  300.       (setf cspnr (cos ang))
  301.       (setf cspni (sin ang))
  302.       (if (= (mod ifn 2) 0) (go label170))
  303.       (setf cspnr (- cspnr))
  304.       (setf cspni (- cspni))
  305.      label170
  306.       (setf asc (f2cl-lib:fref bry (1) ((1 3))))
  307.       (setf iuf 0)
  308.       (setf kk n)
  309.       (setf kdflg 1)
  310.       (setf ib (f2cl-lib:int-sub ib 1))
  311.       (setf ic (f2cl-lib:int-sub ib 1))
  312.       (f2cl-lib:fdo (k 1 (f2cl-lib:int-add k 1))
  313.                     ((> k n) nil)
  314.         (tagbody
  315.           (setf fn (+ fnu (f2cl-lib:int-sub kk 1)))
  316.           (setf m 3)
  317.           (if (> n 2) (go label175))
  318.          label172
  319.           (setf initd (f2cl-lib:fref init (j) ((1 2))))
  320.           (setf phidr (f2cl-lib:fref phir (j) ((1 2))))
  321.           (setf phidi (f2cl-lib:fref phii (j) ((1 2))))
  322.           (setf zet1dr (f2cl-lib:fref zeta1r (j) ((1 2))))
  323.           (setf zet1di (f2cl-lib:fref zeta1i (j) ((1 2))))
  324.           (setf zet2dr (f2cl-lib:fref zeta2r (j) ((1 2))))
  325.           (setf zet2di (f2cl-lib:fref zeta2i (j) ((1 2))))
  326.           (setf sumdr (f2cl-lib:fref sumr (j) ((1 2))))
  327.           (setf sumdi (f2cl-lib:fref sumi (j) ((1 2))))
  328.           (setf m j)
  329.           (setf j (f2cl-lib:int-sub 3 j))
  330.           (go label180)
  331.          label175
  332.           (if (and (= kk n) (< ib n)) (go label180))
  333.           (if (or (= kk ib) (= kk ic)) (go label172))
  334.           (setf initd 0)
  335.          label180
  336.           (multiple-value-bind
  337.               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9
  338.                var-10 var-11 var-12 var-13 var-14 var-15 var-16)
  339.               (zunik zrr zri fn 1 0 tol initd phidr phidi zet1dr zet1di zet2dr
  340.                zet2di sumdr sumdi (f2cl-lib:fref cwrkr (1 m) ((1 16) (1 3)))
  341.                (f2cl-lib:fref cwrki (1 m) ((1 16) (1 3))))
  342.             (declare
  343.              (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-15 var-16))
  344.             (setf initd var-6)
  345.             (setf phidr var-7)
  346.             (setf phidi var-8)
  347.             (setf zet1dr var-9)
  348.             (setf zet1di var-10)
  349.             (setf zet2dr var-11)
  350.             (setf zet2di var-12)
  351.             (setf sumdr var-13)
  352.             (setf sumdi var-14))
  353.           (if (= kode 1) (go label200))
  354.           (setf str (+ zrr zet2dr))
  355.           (setf sti (+ zri zet2di))
  356.           (setf rast (/ fn (zabs str sti)))
  357.           (setf str (* str rast rast))
  358.           (setf sti (* (- sti) rast rast))
  359.           (setf s1r (- str zet1dr))
  360.           (setf s1i (- sti zet1di))
  361.           (go label210)
  362.          label200
  363.           (setf s1r (- zet2dr zet1dr))
  364.           (setf s1i (- zet2di zet1di))
  365.          label210
  366.           (setf rs1 s1r)
  367.           (if (> (abs rs1) elim) (go label260))
  368.           (if (= kdflg 1) (setf iflag 2))
  369.           (if (< (abs rs1) alim) (go label220))
  370.           (setf aphi (zabs phidr phidi))
  371.           (setf rs1 (+ rs1 (f2cl-lib:flog aphi)))
  372.           (if (> (abs rs1) elim) (go label260))
  373.           (if (= kdflg 1) (setf iflag 1))
  374.           (if (< rs1 0.0) (go label220))
  375.           (if (= kdflg 1) (setf iflag 3))
  376.          label220
  377.           (setf str (- (* phidr sumdr) (* phidi sumdi)))
  378.           (setf sti (+ (* phidr sumdi) (* phidi sumdr)))
  379.           (setf s2r (* (- csgni) sti))
  380.           (setf s2i (* csgni str))
  381.           (setf str (* (exp s1r) (f2cl-lib:fref cssr (iflag) ((1 3)))))
  382.           (setf s1r (* str (cos s1i)))
  383.           (setf s1i (* str (sin s1i)))
  384.           (setf str (- (* s2r s1r) (* s2i s1i)))
  385.           (setf s2i (+ (* s2r s1i) (* s2i s1r)))
  386.           (setf s2r str)
  387.           (if (/= iflag 1) (go label230))
  388.           (multiple-value-bind
  389.               (var-0 var-1 var-2 var-3 var-4)
  390.               (zuchk s2r s2i nw (f2cl-lib:fref bry (1) ((1 3))) tol)
  391.             (declare (ignore var-0 var-1 var-3 var-4))
  392.             (setf nw var-2))
  393.           (if (= nw 0) (go label230))
  394.           (setf s2r zeror)
  395.           (setf s2i zeroi)
  396.          label230
  397.           (f2cl-lib:fset (f2cl-lib:fref cyr (kdflg) ((1 2))) s2r)
  398.           (f2cl-lib:fset (f2cl-lib:fref cyi (kdflg) ((1 2))) s2i)
  399.           (setf c2r s2r)
  400.           (setf c2i s2i)
  401.           (setf s2r (* s2r (f2cl-lib:fref csrr (iflag) ((1 3)))))
  402.           (setf s2i (* s2i (f2cl-lib:fref csrr (iflag) ((1 3)))))
  403.           (setf s1r (f2cl-lib:fref yr (kk) ((1 n))))
  404.           (setf s1i (f2cl-lib:fref yi (kk) ((1 n))))
  405.           (if (= kode 1) (go label250))
  406.           (multiple-value-bind
  407.               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
  408.               (zs1s2 zrr zri s1r s1i s2r s2i nw asc alim iuf)
  409.             (declare (ignore var-0 var-1 var-7 var-8))
  410.             (setf s1r var-2)
  411.             (setf s1i var-3)
  412.             (setf s2r var-4)
  413.             (setf s2i var-5)
  414.             (setf nw var-6)
  415.             (setf iuf var-9))
  416.           (setf nz (f2cl-lib:int-add nz nw))
  417.          label250
  418.           (f2cl-lib:fset (f2cl-lib:fref yr (kk) ((1 n)))
  419.                          (+ (- (* s1r cspnr) (* s1i cspni)) s2r))
  420.           (f2cl-lib:fset (f2cl-lib:fref yi (kk) ((1 n)))
  421.                          (+ (* cspnr s1i) (* cspni s1r) s2i))
  422.           (setf kk (f2cl-lib:int-sub kk 1))
  423.           (setf cspnr (- cspnr))
  424.           (setf cspni (- cspni))
  425.           (if (or (/= c2r 0.0) (/= c2i 0.0)) (go label255))
  426.           (setf kdflg 1)
  427.           (go label270)
  428.          label255
  429.           (if (= kdflg 2) (go label275))
  430.           (setf kdflg 2)
  431.           (go label270)
  432.          label260
  433.           (if (> rs1 0.0) (go label300))
  434.           (setf s2r zeror)
  435.           (setf s2i zeroi)
  436.           (go label230)
  437.          label270))
  438.       (setf k n)
  439.      label275
  440.       (setf il (f2cl-lib:int-sub n k))
  441.       (if (= il 0) (go end_label))
  442.       (setf s1r (f2cl-lib:fref cyr (1) ((1 2))))
  443.       (setf s1i (f2cl-lib:fref cyi (1) ((1 2))))
  444.       (setf s2r (f2cl-lib:fref cyr (2) ((1 2))))
  445.       (setf s2i (f2cl-lib:fref cyi (2) ((1 2))))
  446.       (setf csr (f2cl-lib:fref csrr (iflag) ((1 3))))
  447.       (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
  448.       (setf fn
  449.               (coerce (the f2cl-lib:integer4 (f2cl-lib:int-add inu il))
  450.                       'double-float))
  451.       (f2cl-lib:fdo (i 1 (f2cl-lib:int-add i 1))
  452.                     ((> i il) nil)
  453.         (tagbody
  454.           (setf c2r s2r)
  455.           (setf c2i s2i)
  456.           (setf s2r (+ s1r (* (+ fn fnf) (- (* rzr c2r) (* rzi c2i)))))
  457.           (setf s2i (+ s1i (* (+ fn fnf) (+ (* rzr c2i) (* rzi c2r)))))
  458.           (setf s1r c2r)
  459.           (setf s1i c2i)
  460.           (setf fn (- fn 1.0))
  461.           (setf c2r (* s2r csr))
  462.           (setf c2i (* s2i csr))
  463.           (setf ckr c2r)
  464.           (setf cki c2i)
  465.           (setf c1r (f2cl-lib:fref yr (kk) ((1 n))))
  466.           (setf c1i (f2cl-lib:fref yi (kk) ((1 n))))
  467.           (if (= kode 1) (go label280))
  468.           (multiple-value-bind
  469.               (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9)
  470.               (zs1s2 zrr zri c1r c1i c2r c2i nw asc alim iuf)
  471.             (declare (ignore var-0 var-1 var-7 var-8))
  472.             (setf c1r var-2)
  473.             (setf c1i var-3)
  474.             (setf c2r var-4)
  475.             (setf c2i var-5)
  476.             (setf nw var-6)
  477.             (setf iuf var-9))
  478.           (setf nz (f2cl-lib:int-add nz nw))
  479.          label280
  480.           (f2cl-lib:fset (f2cl-lib:fref yr (kk) ((1 n)))
  481.                          (+ (- (* c1r cspnr) (* c1i cspni)) c2r))
  482.           (f2cl-lib:fset (f2cl-lib:fref yi (kk) ((1 n)))
  483.                          (+ (* c1r cspni) (* c1i cspnr) c2i))
  484.           (setf kk (f2cl-lib:int-sub kk 1))
  485.           (setf cspnr (- cspnr))
  486.           (setf cspni (- cspni))
  487.           (if (>= iflag 3) (go label290))
  488.           (setf c2r (coerce (abs ckr) 'double-float))
  489.           (setf c2i (coerce (abs cki) 'double-float))
  490.           (setf c2m (max c2r c2i))
  491.           (if (<= c2m ascle) (go label290))
  492.           (setf iflag (f2cl-lib:int-add iflag 1))
  493.           (setf ascle (f2cl-lib:fref bry (iflag) ((1 3))))
  494.           (setf s1r (* s1r csr))
  495.           (setf s1i (* s1i csr))
  496.           (setf s2r ckr)
  497.           (setf s2i cki)
  498.           (setf s1r (* s1r (f2cl-lib:fref cssr (iflag) ((1 3)))))
  499.           (setf s1i (* s1i (f2cl-lib:fref cssr (iflag) ((1 3)))))
  500.           (setf s2r (* s2r (f2cl-lib:fref cssr (iflag) ((1 3)))))
  501.           (setf s2i (* s2i (f2cl-lib:fref cssr (iflag) ((1 3)))))
  502.           (setf csr (f2cl-lib:fref csrr (iflag) ((1 3))))
  503.          label290))
  504.       (go end_label)
  505.      label300
  506.       (setf nz -1)
  507.       (go end_label)
  508.      end_label
  509.       (return (values nil nil nil nil nil nil nil nil nz nil nil nil)))))
  510.  
  511.